home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1995 January / Simtel - 10000 MSDOS Shareware Programs (Walnut Creek)(January 1995)(Disc 1).ISO / starter / uuencode.tp5 < prev    next >
Pascal/Delphi Source File  |  1990-05-08  |  5KB  |  222 lines

  1. PROGRAM uuencode;
  2.  
  3. {v1.1 Toad Hall Tweak, 9 May 90
  4.  - Converted reserved, other word case to my preferred style.
  5.  - Converted for Turbo Pascal v5.0 compilation ("Uses", etc.)
  6. }
  7.  
  8. Uses Dos,Crt;
  9.  
  10. CONST
  11.   Header = 'begin';
  12.   Trailer = 'end';
  13.   DefaultMode = '644';
  14.   DefaultExtension = '.uue';
  15.   OFFSET = 32;
  16.   CHARSPERLINE = 60;
  17.   BYTESPERHUNK = 3;
  18.   SIXBITMASK = $3F;
  19.  
  20. TYPE
  21.   Str80 = STRING[80];
  22.  
  23. VAR
  24.   Infile: FILE OF Byte;
  25.   Outfile: TEXT;
  26.   Infilename, Outfilename, Mode: Str80;
  27.   lineLength, numbytes, bytesInLine: INTEGER;
  28.   Line: ARRAY [0..59] OF CHAR;
  29.   hunk: ARRAY [0..2] OF Byte;
  30.   chars: ARRAY [0..3] OF Byte;
  31.   size,remaining : longint;  {v1.1 REAL;}
  32.  
  33. {  procedure debug;
  34.     var i: integer;
  35.  
  36.     procedure writebin(x: byte);
  37.       var i: integer;
  38.       begin
  39.         for i := 1 to 8 do begin
  40.             write ((x and $80) shr 7);
  41.             x := x shl 1
  42.           end;
  43.         write (' ')
  44.       end;
  45.  
  46.     begin
  47.       for i := 0 to 2 do writebin(hunk[i]);
  48.       writeln;
  49.       for i := 0 to 3 do writebin(chars[i]);
  50.       writeln;
  51.       for i := 0 to 3 do writebin(chars[i] and SIXBITMASK);
  52.       writeln
  53.     end;  }
  54.  
  55. PROCEDURE Abort (Msg : Str80);
  56.   BEGIN
  57.     WRITELN(Msg);
  58.     {$I-}                 {v1.1}
  59.     CLOSE(Infile);
  60.     CLOSE(Outfile);
  61.     {$I+}                 {v1.1}
  62.     HALT
  63.   END; {of Abort}
  64.  
  65.  
  66. PROCEDURE Init;
  67.  
  68.   PROCEDURE GetFiles;
  69.     VAR
  70.       i : INTEGER;
  71.       TempS : Str80;
  72.       Ch : CHAR;
  73.     BEGIN
  74.       IF ParamCount < 1 THEN Abort ('No input file specified.');
  75.       Infilename := ParamStr(1);
  76.       {$I-}
  77.       ASSIGN (Infile, Infilename);
  78.       RESET (Infile);
  79.       {$I+}
  80.       IF IOResult > 0 THEN Abort (CONCAT ('Can''t open file ', Infilename));
  81.  
  82.       size := FileSize(Infile);
  83. {     IF size < 0 THEN size:=size+65536.0; }
  84.       remaining := size;
  85.       WRITE('Uuencoding file ', Infilename);
  86.  
  87.       i := POS('.', Infilename);
  88.       IF i = 0
  89.       THEN Outfilename := Infilename
  90.       ELSE Outfilename := COPY (Infilename, 1, PRED(i));
  91.  
  92.       Mode := DefaultMode;
  93.       { Process 2d cmdline arg (if any).
  94.         It could be a new mode (rather than default "644")
  95.         or it could be a forced output name (rather than
  96.         "infile.uue")
  97.       }
  98.       IF ParamCount > 1                         {got more args}
  99.       THEN FOR i := 2 TO ParamCount DO BEGIN
  100.         TempS := ParamStr(i);
  101.         IF TempS[1] IN ['0'..'9']               {numeric : it's a mode}
  102.         THEN Mode := TempS
  103.         ELSE Outfilename := TempS               {it's output filename}
  104.       END;
  105.  
  106.       IF POS ('.', Outfilename) = 0       {he didn't give us extension..}
  107.                                           {..so make it ".uue"}
  108.       THEN Outfilename := CONCAT(Outfilename, DefaultExtension);
  109.  
  110.       ASSIGN (Outfile, Outfilename);
  111.       WRITELN (' to file ', Outfilename, '.');
  112.  
  113.       {$I-}
  114.       RESET(Outfile);
  115.       {$I+}
  116.       IF IOResult = 0 THEN BEGIN          {output file exists!}
  117.         WRITE ('Overwrite current ', Outfilename, '? [Y/N] ');
  118.         REPEAT
  119.           Ch := Upcase(ReadKey);
  120.         UNTIL Ch IN ['Y', 'N'];
  121.         WRITELN (Ch);
  122.         IF Ch = 'N' THEN Abort(CONCAT (Outfilename, ' not overwritten.'))
  123.       END;
  124.  
  125.       {$I-}
  126.       CLOSE(Outfile);
  127.       IF IOResult <> 0 THEN ;  {v1.1 we don't care}
  128.  
  129.       REWRITE(Outfile);
  130.       {$I+}
  131.       IF IOResult > 0 THEN Abort(CONCAT('Can''t open ', Outfilename));
  132.     END; {of GetFiles}
  133.  
  134.   BEGIN {Init}
  135.     GetFiles;
  136.     bytesInLine := 0;
  137.     lineLength := 0;
  138.     numbytes := 0;
  139.     WRITELN (Outfile, Header, ' ', Mode, ' ', Infilename);
  140.   END; {init}
  141.  
  142.  
  143. {You'll notice from here on we don't do any error-trapping on disk
  144.  read/writes.  We just let DOS do the job.  Any errors are terminal
  145.  anyway, right?
  146. }
  147.  
  148. PROCEDURE FlushLine;
  149.   VAR i: INTEGER;
  150.  
  151.  
  152.   PROCEDURE WriteOut(Ch: CHAR);
  153.     BEGIN
  154.       IF Ch = ' ' THEN WRITE(Outfile, '`')
  155.                   ELSE WRITE(Outfile, Ch)
  156.     END; {of WriteOut}
  157.  
  158.   BEGIN {FlushLine}
  159.     {write ('.');}
  160.     WRITE('bytes remaining: ',remaining:7,' (',
  161.           remaining/size*100.0:3:0,'%)',CHR(13));
  162.     WriteOut(CHR(bytesInLine + OFFSET));
  163.     FOR i := 0 TO PRED(lineLength) DO
  164.       WriteOut(Line[i]);
  165.     WRITELN (Outfile);
  166.     lineLength := 0;
  167.     bytesInLine := 0
  168.   END; {of FlushLine}
  169.  
  170.  
  171. PROCEDURE FlushHunk;
  172.   VAR i: INTEGER;
  173.   BEGIN
  174.     IF lineLength = CHARSPERLINE THEN FlushLine;
  175.     chars[0] := hunk[0] ShR 2;
  176.     chars[1] := (hunk[0] ShL 4) + (hunk[1] ShR 4);
  177.     chars[2] := (hunk[1] ShL 2) + (hunk[2] ShR 6);
  178.     chars[3] := hunk[2] AND SIXBITMASK;
  179.     {debug;}
  180.     FOR i := 0 TO 3 DO BEGIN
  181.       Line[lineLength] := CHR((chars[i] AND SIXBITMASK) + OFFSET);
  182.       {write(line[linelength]:2);}
  183.       Inc(lineLength);
  184.     END;
  185.     {writeln;}
  186.     Inc(bytesInLine,numbytes);
  187.     numbytes := 0
  188.   END; {of FlushHunk}
  189.  
  190.  
  191. PROCEDURE Encode1;
  192.   BEGIN
  193.     IF numbytes = BYTESPERHUNK THEN FlushHunk;
  194.  
  195.     READ (Infile, hunk[numbytes]);
  196.     Dec(remaining);
  197.     Inc(numbytes);
  198.   END; {of Encode1}
  199.  
  200.  
  201. PROCEDURE Terminate;
  202.   BEGIN
  203.     IF numbytes > 0 THEN FlushHunk;
  204.     IF lineLength > 0 THEN BEGIN
  205.       FlushLine;
  206.       FlushLine;
  207.     END
  208.     ELSE FlushLine;
  209.  
  210.     WRITELN (Outfile, Trailer);
  211.     CLOSE (Outfile);
  212.     CLOSE (Infile);
  213.   END; {Terminate}
  214.  
  215.  
  216.   BEGIN {uuencode}
  217.     Init;
  218.     WHILE NOT EOF (Infile) DO Encode1;
  219.     Terminate;
  220.     WRITELN;
  221.   END. {uuencode}
  222.